home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / prim / cmdloop1.el.z / cmdloop1.el
Encoding:
Text File  |  1998-05-21  |  5.6 KB  |  153 lines
  1. ;;; cmdloop.el
  2. ;; Copyright (C) 1992, 1993 Free Software Foundation, Inc.
  3.  
  4. ;; This file is part of XEmacs.
  5.  
  6. ;; XEmacs is free software; you can redistribute it and/or modify it
  7. ;; under the terms of the GNU General Public License as published by
  8. ;; the Free Software Foundation; either version 2, or (at your option)
  9. ;; any later version.
  10.  
  11. ;; XEmacs is distributed in the hope that it will be useful, but
  12. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14. ;; General Public License for more details.
  15.  
  16. ;; You should have received a copy of the GNU General Public License
  17. ;; along with XEmacs; see the file COPYING.  If not, write to the 
  18. ;; Free Software Foundation, 59 Temple Place - Suite 330,
  19. ;; Boston, MA 02111-1307, USA.
  20.  
  21. ;;; Synched up with: Not in FSF.
  22.  
  23. ;; Written by Richard Mlynarik 8-Jul-92
  24.  
  25. ;; Putting this in lisp slows things down.
  26.  
  27. (defun recursive-edit ()
  28.   "Invoke the editor command loop recursively.
  29. To get out of the recursive edit, a command can do `(throw 'exit nil)';
  30. that tells this function to return.
  31. Alternately, `(throw 'exit t)' makes this function signal an error."
  32.   (interactive)
  33.   (let ((command-loop-level (1+ command-loop-level)))
  34.     (redraw-modeline)
  35.     (let ((_buf (and (not (eq (current-buffer)
  36.                   (window-buffer (selected-window))))
  37.              (current-buffer))))
  38.       (unwind-protect
  39.            ;; command_loop
  40.            (if (catch 'exit
  41.                  (let ((standard-output t)
  42.                        (standard-input t))
  43.                    ;; command_loop_2
  44.                    (while t (funcall command-loop t))))
  45.                ;; turn abort-recursive-edit into a quit
  46.                (signal 'quit '()))
  47.         (if _buf (set-buffer _buf))
  48.         (redraw-modeline)))
  49.     nil))
  50.  
  51. ;; We demand lexical scope!
  52. (defun command-loop (_catch_errors)
  53.   "This function is the default value of the variable command-loop."
  54.   (setq prefix-arg nil)
  55.   (setq last-command 't)
  56.   (cond ((not _catch_errors)
  57.          (command-loop-1))
  58.         ((> (recursion-depth) 0)
  59.          (while (condition-case e
  60.                     (command-loop-1)
  61.                   (t (command-error e) t))))
  62.         (t
  63.          (if (not (null top-level))
  64.              ;; On entry to the outer level, run the startup file
  65.              (condition-case e
  66.                  (catch 'top-level
  67.                    (eval top-level))
  68.                (t (command-error e))))
  69.  
  70.      ;; If an error occurred during startup and the initial device
  71.      ;; wasn't created, then die now (the error was already printed out
  72.      ;; on the terminal device).
  73.      (if (and (not (noninteractive))
  74.           (or (not (devicep (selected-device)))
  75.               (eq 'terminal (device-type (selected-device)))))
  76.          (kill-emacs -1))
  77.  
  78.      ;; End of -batch run causes exit here.
  79.          (if (noninteractive)
  80.              (kill-emacs t))
  81.  
  82.          (catch 'top-level
  83.            (while (condition-case e
  84.                       (command-loop-1)
  85.                     (t (command-error e) t)))))))
  86.  
  87. ;; Putting this in lisp slows things down a lot; see also comment above.
  88. ;(defun command-loop-1 ()
  89. ;  (let ((_event (allocate-event))
  90. ;      (_old-command-loop command-loop)
  91. ;      ;; We deal with quits ourself
  92. ;      (_old-inhibit-quit inhibit-quit)
  93. ;      (inhibit-quit t))
  94. ;
  95. ;  ;; ## cancel_echoing();
  96. ;
  97. ;  ;; This magically makes single character keyboard macros work just
  98. ;  ;; like the real thing.  This is slightly bogus, but it's in here for
  99. ;  ;; compatibility with Emacs 18.
  100. ;  ;; It's not even clear what the "right thing" is.
  101. ;  (and executing-macro
  102. ;       (eq (length executing-macro) 1)
  103. ;       (setq last-command 't))
  104. ;
  105. ;  ;; Keep looping until somebody wants a different command-loop
  106. ;  (while (eq command-loop _old-command-loop)
  107. ;
  108. ;    ;; Make sure current window's buffer is selected.
  109. ;    (set-buffer (window-buffer (selected-window)))
  110. ;
  111. ;    ;; C code had a `QUIT' here so that if ^G was typed before we got here
  112. ;    ;; (that is, before emacs was idle and waiting for input) then we treat
  113. ;    ;; that as an interrupt.  The easiest way to do that here is to make a
  114. ;    ;; function call (but pick one the compiler won't optimize away...)
  115. ;    (let ((inhibit-quit _old-inhibit-quit)) (eval nil))
  116. ;
  117. ;    ;; This condition-case was originally just wrapped around the
  118. ;    ;;  call to dispatch-event, but in fact we can have errors signalled
  119. ;    ;;  by process-filters in either sit-for and next-event.  Those errors
  120. ;    ;;  shouldn't be fatal to the command-loop, so we put the condition-case
  121. ;    ;;  here and hope we're not hiding other bugs in the process.
  122. ;    (condition-case e
  123. ;        (progn
  124. ;          (if (and (> (minibuffer-depth) 0)
  125. ;                   (message-displayed-p))
  126. ;              (progn
  127. ;                (sit-for 2)
  128. ;                (message nil)))
  129. ;
  130. ;          (next-event _event)
  131. ;          ;; If ^G was typed while emacs was reading input from the user, 
  132. ;          ;; then it is treated as just another key.  This is what v18
  133. ;          ;; did.  This is bogus because it gives the illusion that one
  134. ;          ;; can bind commands to sequences involving ^G, when really one
  135. ;          ;; can only execute those sequences in non-typeahead contexts.
  136. ;          (setq quit-flag nil)
  137. ;
  138. ;          (let ((inhibit-quit _old-inhibit-quit))
  139. ;            (dispatch-event _event))
  140. ;
  141. ;          ;; check for bogus code trying to use the old method of unreading.
  142. ;          (if (globally-boundp 'unread-command-char)
  143. ;              (progn
  144. ;                (makunbound 'unread-command-char)
  145. ;                (error
  146. ;                 "%S set unread-command-char instead of unread-command-event."
  147. ;           this-command)))
  148. ;        )
  149. ;        (t
  150. ;         (command-error e))))))
  151.  
  152. (setq-default command-loop 'command-loop)
  153.